@@ -1,5 +1,11 @@
Revision history for Perl extension Test::TCP
+1.12
+
+ - workaround for win32 test fails.
+ https://rt.cpan.org/Ticket/Display.html?id=66016
+ - more diagnostic messages
+
1.11
- localize $@ in Test::TCP::DESTROY
@@ -24,4 +24,4 @@ requires:
perl: 5.8.0
resources:
license: http://dev.perl.org/licenses/
-version: 1.11
+version: 1.12
@@ -8,7 +8,7 @@ requires 'IO::Socket::INET' => 0;
requires 'Test::SharedFork' => 0.14;
tests 't/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t';
-test_requires 'Test::More';
+test_requires 'Test::More' => 0.98;
author_tests 'xt';
auto_include;
WriteAll;
@@ -18,7 +18,7 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.97_01';
+our $VERSION = '0.98';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
@@ -88,7 +88,7 @@ sub ok ($;$) {
return $tb->ok( $test, $name );
}
-#line 367
+#line 372
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +104,7 @@ sub isnt ($$;$) {
*isn't = \&isnt;
-#line 411
+#line 416
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -112,7 +112,7 @@ sub like ($$;$) {
return $tb->like(@_);
}
-#line 426
+#line 431
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -120,7 +120,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 471
+#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -128,7 +128,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 506
+#line 511
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -162,7 +162,7 @@ sub can_ok ($@) {
return $ok;
}
-#line 572
+#line 577
sub isa_ok ($$;$) {
my( $object, $class, $obj_name ) = @_;
@@ -222,7 +222,7 @@ WHOA
return $ok;
}
-#line 651
+#line 656
sub new_ok {
my $tb = Test::More->builder;
@@ -247,7 +247,7 @@ sub new_ok {
return $obj;
}
-#line 736
+#line 741
sub subtest {
my ($name, $subtests) = @_;
@@ -256,7 +256,7 @@ sub subtest {
return $tb->subtest(@_);
}
-#line 760
+#line 765
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +270,7 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 828
+#line 833
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -332,7 +332,7 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 897
+#line 902
sub require_ok ($) {
my($module) = shift;
@@ -376,7 +376,7 @@ sub _is_module_name {
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
-#line 974
+#line 979
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -483,7 +483,7 @@ sub _type {
return '';
}
-#line 1134
+#line 1139
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +493,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1160
+#line 1165
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1226
+#line 1231
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +527,7 @@ sub skip {
last SKIP;
}
-#line 1310
+#line 1315
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +548,7 @@ sub todo_skip {
last TODO;
}
-#line 1365
+#line 1370
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +557,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1404
+#line 1409
#'#
sub eq_array {
@@ -697,7 +697,7 @@ WHOA
}
}
-#line 1551
+#line 1556
sub eq_hash {
local @Data_Stack = ();
@@ -732,7 +732,7 @@ sub _eq_hash {
return $ok;
}
-#line 1610
+#line 1615
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -757,6 +757,6 @@ sub eq_set {
);
}
-#line 1812
+#line 1817
1;
@@ -2,7 +2,7 @@ package Test::TCP;
use strict;
use warnings;
use 5.00800;
-our $VERSION = '1.11';
+our $VERSION = '1.12';
use base qw/Exporter/;
use IO::Socket::INET;
use Test::SharedFork 0.12;
@@ -108,12 +108,16 @@ sub start {
my $self = shift;
if ( my $pid = fork() ) {
# parent.
- Test::TCP::wait_port($self->port);
$self->{pid} = $pid;
+ Test::TCP::wait_port($self->port);
return;
} elsif ($pid == 0) {
# child process
$self->{code}->($self->port);
+ # should not reach here
+ if (kill 0, $self->{_my_pid}) { # warn only parent process still exists
+ warn("[Test::TCP] Child process does not block(PID: $$, PPID: $self->{_my_pid})");
+ }
exit 0;
} else {
die "fork failed: $!";
@@ -163,46 +167,48 @@ Test::TCP - testing TCP program
=head1 SYNOPSIS
use Test::TCP;
- test_tcp(
- client => sub {
- my ($port, $server_pid) = @_;
- # send request to the server
- },
- server => sub {
+
+ my $server = Test::TCP->new(
+ code => sub {
my $port = shift;
- # run server
+ ...
},
);
+ my $client = MyClient->new(host => '127.0.0.1', port => $server->port);
+ undef $server; # kill child process on DESTROY
-using other server program
+Using memcached:
use Test::TCP;
- test_tcp(
- client => sub {
+
+ my $memcached = Test::TCP->new(
+ code => sub {
my $port = shift;
- # send request to the server
- },
- server => sub {
- exec '/foo/bar/bin/server', 'options';
+
+ exec $bin, '-p' => $port;
+ die "cannot execute $bin: $!";
},
);
+ my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]});
+ ...
-Or, OO-ish interface
+And functional interface is available:
use Test::TCP;
-
- my $server = Test::TCP->new(
- code => sub {
+ test_tcp(
+ client => sub {
+ my ($port, $server_pid) = @_;
+ # send request to the server
+ },
+ server => sub {
my $port = shift;
- ...
+ # run server
},
);
- my $client = MyClient->new(host => '127.0.0.1', port => $server->port);
- undef $server; # kill child process on DESTROY
=head1 DESCRIPTION
-Test::TCP is test utilities for TCP/IP program.
+Test::TCP is test utilities for TCP/IP programs.
=head1 METHODS
@@ -216,6 +222,8 @@ Get the available port number, you can use.
=item test_tcp
+Functional interface.
+
test_tcp(
client => sub {
my $port = shift;
@@ -2,3 +2,5 @@ use strict;
use Test::More tests => 1;
BEGIN { use_ok 'Test::TCP' }
+
+diag "Test::More: $Test::More::VERSION";
@@ -1,27 +1,40 @@
use warnings;
use strict;
-use Test::More tests => 1;
+use Test::More tests => 2;
use Test::TCP;
use t::Server;
-# ABOUT: some tcp server related software returns control when received SIGTERM
+# ABOUT: some tcp server related software returns control when received SIGTERM instead of exit.
+# This test emulate it's situation.
test_tcp(
client => sub {
ok 1;
- # nop
+ # nop... but after this statement, Test::TCP send SIGTERM to server process.
},
server => sub {
my $port = shift;
my $sock = new_sock($port);
- my $i = 0;
- $SIG{TERM} = sub { $i++ };
- while ($i == 0) {
+ my $term_received = 0;
+ $SIG{TERM} = sub { $term_received++ };
+ while ($term_received == 0) {
my $csock = $sock->accept;
if ($csock) {
$csock->close();
}
}
+
+ # suppress warnings: [Test::TCP] Child process does not block(PID: 84792, PPID: 84791)
+ # I do it on purpose!
+ $SIG{__WARN__} = sub { };
},
);
+if ($?) {
+ # It's maybe ActivePerl's bug.
+ # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt
+ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
+ $? = 0;
+}
+
+ok 1, 'test finished.';
@@ -26,3 +26,10 @@ like $e, qr/sinamon/;
my $killed = kill 9, $child_pid;
is $killed, 0, "already killed by test_tcp";
+if ($?) {
+ # It's maybe ActivePerl's bug.
+ # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt
+ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
+ $? = 0;
+}
+
@@ -24,3 +24,7 @@ test_tcp(
},
);
+if ($?) {
+ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
+ $? = 0;
+}
@@ -50,3 +50,9 @@ test_tcp
}
;
+if ($?) {
+ # It's maybe ActivePerl's bug.
+ # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt
+ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
+ $? = 0;
+}
@@ -37,5 +37,12 @@ is $res2, "bar\n";
note "finalize";
print {$sock} "quit\n";
+if ($?) {
+ # It's maybe ActivePerl's bug.
+ # http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt
+ diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
+ $? = 0;
+}
+
done_testing;